home *** CD-ROM | disk | FTP | other *** search
/ The Atari Compendium / The Atari Compendium (Toad Computers) (1994).iso / files / prgtools / langs / xlisp2.1 / xldist02.zoo / sources / xlsubr.c < prev    next >
Encoding:
C/C++ Source or Header  |  1990-11-09  |  4.3 KB  |  203 lines
  1. /* xlsubr - xlisp builtin function support routines */
  2. /*        Copyright (c) 1985, by David Michael Betz
  3.         All Rights Reserved
  4.         Permission is granted for unrestricted non-commercial use        */
  5.  
  6. #include "xlisp.h"
  7. #include <string.h>
  8.  
  9. /* external variables */
  10. extern LVAL k_test,k_tnot,s_eql;
  11.  
  12. /* xlsubr - define a builtin function */
  13. #ifdef ANSI
  14. LVAL xlsubr(char *sname, int type, LVAL (*fcn)(void), int offset)
  15. #else
  16. LVAL xlsubr(sname,type,fcn,offset)
  17.   char *sname; int type; LVAL (*fcn)(); int offset;
  18. #endif
  19. {
  20.     LVAL sym;
  21.     sym = xlenter(sname);
  22.     setfunction(sym,cvsubr(fcn,type,offset));
  23.     return (sym);
  24. }
  25.  
  26. /* xlgetkeyarg - get a keyword argument */
  27. int xlgetkeyarg(key,pval)
  28.   LVAL key,*pval;
  29. {
  30.     LVAL *argv=xlargv;
  31.     int argc=xlargc;
  32.     for (argv = xlargv, argc = xlargc; (argc -= 2) >= 0; argv += 2) {
  33.         if (*argv == key) {
  34.             *pval = *++argv;
  35.             return (TRUE);
  36.         }
  37.     }
  38.     return (FALSE);
  39. }
  40.  
  41. /* xlgkfixnum - get a fixnum keyword argument */
  42. int xlgkfixnum(key,pval)
  43.   LVAL key,*pval;
  44. {
  45.     if (xlgetkeyarg(key,pval)) {
  46.         if (!fixp(*pval))
  47.             xlbadtype(*pval);
  48.         return (TRUE);
  49.     }
  50.     return (FALSE);
  51. }
  52.  
  53. /* xltest - get the :test or :test-not keyword argument */
  54. VOID xltest(pfcn,ptresult)
  55.   LVAL *pfcn; int *ptresult;
  56. {
  57.     if (xlgetkeyarg(k_test,pfcn))        /* :test */
  58.         *ptresult = TRUE;
  59.     else if (xlgetkeyarg(k_tnot,pfcn))    /* :test-not */
  60.         *ptresult = FALSE;
  61.     else {
  62.         *pfcn = getfunction(s_eql);
  63.         *ptresult = TRUE;
  64.     }
  65. }
  66.  
  67. /* xlgetfile - get a file or stream */
  68. LVAL xlgetfile()
  69. {
  70.     LVAL arg;
  71.  
  72.     /* get a file or stream (cons) or nil */
  73.     if ((arg = xlgetarg()) != 0) {
  74.         if (streamp(arg)) {
  75.             if (getfile(arg) == NULL)
  76.                 xlfail("file not open");
  77.         }
  78.         else if (!ustreamp(arg))
  79.             xlbadtype(arg);
  80.     }
  81.     return (arg);
  82. }
  83.  
  84. /* xlgetfname - get a filename */
  85. LVAL xlgetfname()
  86. {
  87.     LVAL name;
  88.  
  89.     /* get the next argument */
  90.     name = xlgetarg();
  91.  
  92.     /* get the filename string */
  93.     if (symbolp(name))
  94.         name = getpname(name);
  95.     else if (!stringp(name))
  96.         xlbadtype(name);
  97.  
  98.     /* return the name */
  99.     return (name);
  100. }
  101.  
  102. /* needsextension - check if a filename needs an extension */
  103. int needsextension(name)
  104.   char *name;
  105. {
  106.     char *p;
  107.  
  108.     /* check for an extension */
  109.     for (p = &name[strlen(name)]; --p >= &name[0]; )
  110.         if (*p == '.')
  111.             return (FALSE);
  112.         else if (!islower(*p) && !isupper(*p) && !isdigit(*p))
  113.             return (TRUE);
  114.  
  115.     /* no extension found */
  116.     return (TRUE);
  117. }
  118.  
  119. /* xlbadtype - report a "bad argument type" error */
  120. LVAL xlbadtype(arg)
  121.   LVAL arg;
  122. {
  123.     return xlerror("bad argument type",arg);
  124. }
  125.  
  126. /* xltoofew - report a "too few arguments" error */
  127. LVAL xltoofew()
  128. {
  129.     xlfail("too few arguments");
  130.     return (NIL);    /* never returns */
  131. }
  132.  
  133. /* xltoomany - report a "too many arguments" error */
  134. VOID xltoomany()
  135. {
  136.     xlfail("too many arguments");
  137. }
  138.  
  139. /* eql - internal eql function */
  140. int eql(arg1,arg2)
  141.   LVAL arg1,arg2;
  142. {
  143.     /* compare the arguments */
  144.     if (arg1 == arg2)
  145.         return (TRUE);
  146.     else if (arg1) {
  147.         switch (ntype(arg1)) {
  148.         case FIXNUM:
  149.             return (fixp(arg2) ? getfixnum(arg1)==getfixnum(arg2) : FALSE);
  150.         case FLONUM:
  151.             return (floatp(arg2) ? getflonum(arg1)==getflonum(arg2) : FALSE);
  152.         default:
  153.             return (FALSE);
  154.         }
  155.     }
  156.     else
  157.         return (FALSE);
  158. }
  159.  
  160. /* equal- internal equal function */
  161. int equal(arg1,arg2)
  162.   LVAL arg1,arg2;
  163. {
  164.     /* compare the arguments */
  165. isItEqual:    /* turn tail recursion into iteration */
  166.     if (arg1 == arg2)
  167.         return (TRUE);
  168.     else if (arg1) {
  169.         switch (ntype(arg1)) {
  170.         case FIXNUM:
  171.             return (fixp(arg2) ? getfixnum(arg1)==getfixnum(arg2) : FALSE);
  172.         case FLONUM:
  173.             return (floatp(arg2) ? getflonum(arg1)==getflonum(arg2) : FALSE);
  174.         case STRING:
  175.             return (stringp(arg2) ? strcmp((char *)getstring(arg1),
  176.                                            (char *)getstring(arg2)) == 0 : FALSE);
  177.         case CONS:    /* TAA MOD turns tail recursion into iteration */
  178.                     /* Not only is this faster, but greatly reduces chance */
  179.                     /* of stack overflow */
  180.             if (consp(arg2) && equal(car(arg1),car(arg2))) {
  181.                 arg1 = cdr(arg1);
  182.                 arg2 = cdr(arg2);
  183.                 goto isItEqual;
  184.             }
  185.             return FALSE;
  186.         case VECTOR: /* TAA MOD to compare vectors. (Why was it missing?) */
  187.             if (vectorp(arg2) && getsize(arg1) == getsize(arg2)) {
  188.                 int i = getsize(arg2);
  189.                 for (;--i >= 0;)
  190.                     if (getelement(arg1,i) != getelement(arg2,i) &&
  191.                         !equal(getelement(arg1,i),getelement(arg2,i)))
  192.                         return (FALSE);
  193.                 return (TRUE);
  194.             }
  195.             return (FALSE);
  196.         default:
  197.             return (FALSE);
  198.         }
  199.     }
  200.     else
  201.         return (FALSE);
  202. }
  203.